home *** CD-ROM | disk | FTP | other *** search
/ PC-Blue - MS DOS Public Domain Library / PC-Blue MS-DOS Public Domain Library - NYACC.iso / vol146 / xlread.c < prev    next >
Encoding:
C/C++ Source or Header  |  1986-12-16  |  9.0 KB  |  424 lines
  1. /* xlread - xlisp expression input routine */
  2. /*    Copyright (c) 1985, by David Michael Betz
  3.     All Rights Reserved
  4.     Permission is granted for unrestricted non-commercial use    */
  5.  
  6. #include "xlisp.h"
  7.  
  8. #ifdef MEGAMAX
  9. overlay "io"
  10. #endif
  11.  
  12. /* external variables */
  13. extern NODE *s_stdout,*true;
  14. extern NODE *s_quote,*s_function,*s_bquote,*s_comma,*s_comat;
  15. extern NODE *xlstack;
  16. extern int xlplevel;
  17. extern char buf[];
  18.  
  19. /* external routines */
  20. extern FILE *fopen();
  21. extern ITYPE;
  22. extern FTYPE;
  23.  
  24. /* forward declarations */
  25. FORWARD NODE *plist();
  26. FORWARD NODE *pstring();
  27. FORWARD NODE *pquote();
  28. FORWARD NODE *pname();
  29.  
  30. /* xlload - load a file of xlisp expressions */
  31. int xlload(fname,vflag,pflag)
  32.   char *fname; int vflag,pflag;
  33. {
  34.     NODE *oldstk,fptr,expr;
  35.     CONTEXT cntxt;
  36.     int sts;
  37.  
  38.     /* create a new stack frame */
  39.     oldstk = xlsave(&fptr,&expr,NULL);
  40.  
  41.     /* allocate a file node */
  42.     fptr.n_ptr = newnode(FPTR);
  43.     fptr.n_ptr->n_fp = NULL;
  44.     fptr.n_ptr->n_savech = 0;
  45.  
  46.     /* print the information line */
  47.     if (vflag)
  48.     { sprintf(buf,"; loading \"%s\"\n",fname); stdputstr(buf); }
  49.  
  50.     /* open the file */
  51.     if ((fptr.n_ptr->n_fp = fopen(fname,"r")) == NULL) {
  52.     xlstack = oldstk;
  53.     return (FALSE);
  54.     }
  55.  
  56.     /* read, evaluate and possibly print each expression in the file */
  57.     xlbegin(&cntxt,CF_ERROR,true);
  58.     if (setjmp(cntxt.c_jmpbuf))
  59.     sts = FALSE;
  60.     else {
  61.     while (xlread(fptr.n_ptr,&expr.n_ptr)) {
  62.         expr.n_ptr = xleval(expr.n_ptr);
  63.         if (pflag)
  64.         stdprint(expr.n_ptr);
  65.     }
  66.     sts = TRUE;
  67.     }
  68.     xlend(&cntxt);
  69.  
  70.     /* close the file */
  71.     fclose(fptr.n_ptr->n_fp);
  72.     fptr.n_ptr->n_fp = NULL;
  73.  
  74.     /* restore the previous stack frame */
  75.     xlstack = oldstk;
  76.  
  77.     /* return status */
  78.     return (sts);
  79. }
  80.  
  81. /* xlread - read an xlisp expression */
  82. int xlread(fptr,pval)
  83.   NODE *fptr,**pval;
  84. {
  85.     /* initialize */
  86.     xlplevel = 0;
  87.  
  88.     /* parse an expression */
  89.     return (parse(fptr,pval));
  90. }
  91.  
  92. /* parse - parse an xlisp expression */
  93. LOCAL int parse(fptr,pval)
  94.   NODE *fptr,**pval;
  95. {
  96.     int ch;
  97.  
  98.     /* keep looking for a node skipping comments */
  99.     while (TRUE)
  100.  
  101.     /* check next character for type of node */
  102.     switch (ch = nextch(fptr)) {
  103.     case EOF:
  104.         xlgetc(fptr);
  105.         return (FALSE);
  106.     case '\'':            /* a quoted expression */
  107.         xlgetc(fptr);
  108.         *pval = pquote(fptr,s_quote);
  109.         return (TRUE);
  110.     case '#':            /* a quoted function */
  111.         xlgetc(fptr);
  112.         if ((ch = xlgetc(fptr)) == '<')
  113.             xlfail("unreadable atom");
  114.         else if (ch != '\'')
  115.             xlfail("expected quote after #");
  116.         *pval = pquote(fptr,s_function);
  117.         return (TRUE);
  118.     case '`':            /* a back quoted expression */
  119.         xlgetc(fptr);
  120.         *pval = pquote(fptr,s_bquote);
  121.         return (TRUE);
  122.     case ',':            /* a comma or comma-at expression */
  123.         xlgetc(fptr);
  124.         if (xlpeek(fptr) == '@') {
  125.             xlgetc(fptr);
  126.             *pval = pquote(fptr,s_comat);
  127.         }
  128.         else
  129.             *pval = pquote(fptr,s_comma);
  130.         return (TRUE);
  131.     case '(':            /* a sublist */
  132.         *pval = plist(fptr);
  133.         return (TRUE);
  134.     case ')':            /* closing paren - shouldn't happen */
  135.         xlfail("extra right paren");
  136.     case '.':            /* dot - shouldn't happen */
  137.         xlfail("misplaced dot");
  138.     case ';':            /* a comment */
  139.         pcomment(fptr);
  140.         break;
  141.     case '"':            /* a string */
  142.         *pval = pstring(fptr);
  143.         return (TRUE);
  144.     default:
  145.         if (issym(ch))        /* a name */
  146.             *pval = pname(fptr);
  147.         else
  148.             xlfail("invalid character");
  149.         return (TRUE);
  150.     }
  151. }
  152.  
  153. /* pcomment - parse a comment */
  154. LOCAL pcomment(fptr)
  155.   NODE *fptr;
  156. {
  157.     int ch;
  158.  
  159.     /* skip to end of line */
  160.     while ((ch = checkeof(fptr)) != EOF && ch != '\n')
  161.     ;
  162. }
  163.  
  164. /* plist - parse a list */
  165. LOCAL NODE *plist(fptr)
  166.   NODE *fptr;
  167. {
  168.     NODE *oldstk,val,*lastnptr,*nptr,*p;
  169.     int ch;
  170.  
  171.     /* increment the nesting level */
  172.     xlplevel += 1;
  173.  
  174.     /* create a new stack frame */
  175.     oldstk = xlsave(&val,NULL);
  176.  
  177.     /* skip the opening paren */
  178.     xlgetc(fptr);
  179.  
  180.     /* keep appending nodes until a closing paren is found */
  181.     lastnptr = NIL;
  182.     for (lastnptr = NIL; (ch = nextch(fptr)) != ')'; lastnptr = nptr) {
  183.  
  184.     /* check for end of file */
  185.     if (ch == EOF)
  186.         badeof(fptr);
  187.  
  188.     /* check for a dotted pair */
  189.     if (ch == '.') {
  190.  
  191.         /* skip the dot */
  192.         xlgetc(fptr);
  193.  
  194.         /* make sure there's a node */
  195.         if (lastnptr == NIL)
  196.         xlfail("invalid dotted pair");
  197.  
  198.         /* parse the expression after the dot */
  199.         if (!parse(fptr,&p))
  200.         badeof(fptr);
  201.         rplacd(lastnptr,p);
  202.  
  203.         /* make sure its followed by a close paren */
  204.         if (nextch(fptr) != ')')
  205.         xlfail("invalid dotted pair");
  206.  
  207.         /* done with this list */
  208.         break;
  209.     }
  210.  
  211.     /* allocate a new node and link it into the list */
  212.     nptr = newnode(LIST);
  213.     if (lastnptr == NIL)
  214.         val.n_ptr = nptr;
  215.     else
  216.         rplacd(lastnptr,nptr);
  217.  
  218.     /* initialize the new node */
  219.     if (!parse(fptr,&p))
  220.         badeof(fptr);
  221.     rplaca(nptr,p);
  222.     }
  223.  
  224.     /* skip the closing paren */
  225.     xlgetc(fptr);
  226.  
  227.     /* restore the previous stack frame */
  228.     xlstack = oldstk;
  229.  
  230.     /* decrement the nesting level */
  231.     xlplevel -= 1;
  232.  
  233.     /* return successfully */
  234.     return (val.n_ptr);
  235. }
  236.  
  237. /* pstring - parse a string */
  238. LOCAL NODE *pstring(fptr)
  239.   NODE *fptr;
  240. {
  241.     NODE *oldstk,val;
  242.     char sbuf[STRMAX+1];
  243.     int ch,i,d1,d2,d3;
  244.  
  245.     /* create a new stack frame */
  246.     oldstk = xlsave(&val,NULL);
  247.  
  248.     /* skip the opening quote */
  249.     xlgetc(fptr);
  250.  
  251.     /* loop looking for a closing quote */
  252.     for (i = 0; i < STRMAX && (ch = checkeof(fptr)) != '"'; i++) {
  253.     switch (ch) {
  254.     case EOF:
  255.         badeof(fptr);
  256.     case '\\':
  257.         switch (ch = checkeof(fptr)) {
  258.         case 'e':
  259.             ch = '\033';
  260.             break;
  261.         case 'n':
  262.             ch = '\n';
  263.             break;
  264.         case 'r':
  265.             ch = '\r';
  266.             break;
  267.         case 't':
  268.             ch = '\t';
  269.             break;
  270.         default:
  271.             if (ch >= '0' && ch <= '7') {
  272.                 d1 = ch - '0';
  273.                 d2 = checkeof(fptr) - '0';
  274.                 d3 = checkeof(fptr) - '0';
  275.                 ch = (d1 << 6) + (d2 << 3) + d3;
  276.             }
  277.             break;
  278.         }
  279.     }
  280.     sbuf[i] = ch;
  281.     }
  282.     sbuf[i] = 0;
  283.  
  284.     /* initialize the node */
  285.     val.n_ptr = newnode(STR);
  286.     val.n_ptr->n_str = strsave(sbuf);
  287.     val.n_ptr->n_strtype = DYNAMIC;
  288.  
  289.     /* restore the previous stack frame */
  290.     xlstack = oldstk;
  291.  
  292.     /* return the new string */
  293.     return (val.n_ptr);
  294. }
  295.  
  296. /* pquote - parse a quoted expression */
  297. LOCAL NODE *pquote(fptr,sym)
  298.   NODE *fptr,*sym;
  299. {
  300.     NODE *oldstk,val,*p;
  301.  
  302.     /* create a new stack frame */
  303.     oldstk = xlsave(&val,NULL);
  304.  
  305.     /* allocate two nodes */
  306.     val.n_ptr = newnode(LIST);
  307.     rplaca(val.n_ptr,sym);
  308.     rplacd(val.n_ptr,newnode(LIST));
  309.  
  310.     /* initialize the second to point to the quoted expression */
  311.     if (!parse(fptr,&p))
  312.     badeof(fptr);
  313.     rplaca(cdr(val.n_ptr),p);
  314.  
  315.     /* restore the previous stack frame */
  316.     xlstack = oldstk;
  317.  
  318.     /* return the quoted expression */
  319.     return (val.n_ptr);
  320. }
  321.  
  322. /* pname - parse a symbol name */
  323. LOCAL NODE *pname(fptr)
  324.   NODE *fptr;
  325. {
  326.     char sname[STRMAX+1];
  327.     NODE *val;
  328.     int ch,i;
  329.  
  330.     /* get symbol name */
  331.     for (i = 0; i < STRMAX && (ch = xlpeek(fptr)) != EOF && issym(ch); ) {
  332.     sname[i++] = (islower(ch) ? toupper(ch) : ch);
  333.     xlgetc(fptr);
  334.     }
  335.     sname[i] = 0;
  336.  
  337.     /* check for a number or enter the symbol into the oblist */
  338.     return (isnumber(sname,&val) ? val : xlenter(sname,DYNAMIC));
  339. }
  340.  
  341. /* nextch - look at the next non-blank character */
  342. LOCAL int nextch(fptr)
  343.   NODE *fptr;
  344. {
  345.     int ch;
  346.  
  347.     /* return and save the next non-blank character */
  348.     while ((ch = xlpeek(fptr)) != EOF && isspace(ch))
  349.     xlgetc(fptr);
  350.     return (ch);
  351. }
  352.  
  353. /* checkeof - get a character and check for end of file */
  354. LOCAL int checkeof(fptr)
  355.   NODE *fptr;
  356. {
  357.     int ch;
  358.  
  359.     if ((ch = xlgetc(fptr)) == EOF)
  360.     badeof(fptr);
  361.     return (ch);
  362. }
  363.  
  364. /* badeof - unexpected eof */
  365. LOCAL badeof(fptr)
  366.   NODE *fptr;
  367. {
  368.     xlgetc(fptr);
  369.     xlfail("unexpected EOF");
  370. }
  371.  
  372. /* isnumber - check if this string is a number */
  373. int isnumber(str,pval)
  374.   char *str; NODE **pval;
  375. {
  376.     int dl,dr;
  377.     char *p;
  378.  
  379.     /* initialize */
  380.     p = str; dl = dr = 0;
  381.  
  382.     /* check for a sign */
  383.     if (*p == '+' || *p == '-')
  384.     p++;
  385.  
  386.     /* check for a string of digits */
  387.     while (isdigit(*p))
  388.     p++, dl++;
  389.  
  390.     /* check for a decimal point */
  391.     if (*p == '.') {
  392.     p++;
  393.     while (isdigit(*p))
  394.         p++, dr++;
  395.     }
  396.  
  397.     /* make sure there was at least one digit and this is the end */
  398.     if ((dl == 0 && dr == 0) || *p)
  399.     return (FALSE);
  400.  
  401.     /* convert the string to an integer and return successfully */
  402.     if (*str == '+') ++str;
  403.     if (str[strlen(str)-1] == '.') str[strlen(str)-1] = 0;
  404.     *pval = (dr ? cvflonum(FCNV(str)) : cvfixnum(ICNV(str)));
  405.     return (TRUE);
  406. }
  407.  
  408. /* issym - check whether a character if valid in a symbol name */
  409. LOCAL int issym(ch)
  410.   int ch;
  411. {
  412.     if (ch <= ' ' || ch >= 0177 ||
  413.         ch == '(' ||
  414.         ch == ')' ||
  415.         ch == ';' || 
  416.     ch == ',' ||
  417.     ch == '`' ||
  418.         ch == '"' ||
  419.         ch == '\'')
  420.     return (FALSE);
  421.     else
  422.     return (TRUE);
  423. }
  424.